home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / dates3.com / DATES3.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-05-11  |  6.9 KB  |  215 lines
  1.  
  2. {
  3. This unit is based on the unit 'Dates' by Scott Bussinger.  I liked what he
  4. did in his unit, but I was bothered by the fact that someone over the age of
  5. 89 years couldn't have their birthdate represented.  I considered just moving
  6. his minimun year (1900) back 20 years, but then future dates were also limited.
  7. This unit will allow dates from 1/1/1583 to 12/31/2300, but you do pay a price
  8. for this enhanced capability, the dates are stored as three bytes instead of
  9. two as in the original dates unit.  I think this enhanced version is worth the
  10. extra byte of storage.  I have used 2 or 3 of his routines almost verbatim, but
  11. others are completely rewritten, or in some cases improved upon.
  12.  
  13. NOTE: The minimum year 1583 is the absolute minimum, as the Gregorian calendar
  14. started that year (actually 10/15/1582).  The maximum year of 2300 was
  15. arbitrarily picked by me.  You can raise it several thousand years if you
  16. desire.  The number indicating the days from 1/1/1583 (#1) is the MD number or
  17. Murphy Day, not to be confused with the JD number, the Julian Day which was
  18. devised by Joseph Scalinger in 1582.
  19.  
  20.                               Jim Murphy [74030,2643]
  21. }
  22.  
  23.  
  24. unit dates3;
  25.  
  26. interface
  27.  
  28. uses dos;
  29.  
  30. type
  31.   str3=string[3];
  32.   str9=string[9];
  33.  
  34. const
  35.   minyear=1583;
  36.   maxyear=2300;
  37.  
  38.   monthstr:array[1..12] of str9=('January','February','March','April','May',
  39.                                       'June','July','August','September',
  40.                                       'October','November','December');
  41.  
  42.   daystr:array[0..6] of str9=('Sunday','Monday','Tuesday','Wednesday',
  43.                                    'Thursday','Friday','Saturday');
  44.  
  45.  
  46. function validdate(month,day,year:word):boolean;
  47. { Returns a TRUE if date is legal and within valid years }
  48. function daynumber(datenum:longint):word;
  49. { Returns the number of the day of week (0 to 6) for a given 'datenumber' }
  50. function daystring(daynum:word):str9;
  51. { Takes a daynumber and returns a string containing the day of the week }
  52. function monthstring(monthnum:word):str9;
  53. { Takes the month number (1 to 12) and returns a string containing the month }
  54. function datenumber(month,day,year:word):longint;
  55. { Takes the date (mm dd yyyy) and returns the datenumber for that date }
  56. procedure numberdate(datenum:longint; var month,day,year:word);
  57. { Converts the datenumber for a date and returns the Month, Day, Year }
  58. function today:longint;
  59. { Returns the datenumber for the present date }
  60. function agetoday(datenum:longint):word;
  61. { Takes the datenumber for a given date, and returns the Age today }
  62. function numstring(datenum:longint):str3;
  63. { Converts the datenumber to a sortable 3 byte string for database storage }
  64. function stringnum(numstr:string):longint;
  65. { Converts the 3 byte sortable string back to the original datenumber }
  66. function bumpdate(datenum:longint; months,days,years:integer):longint;
  67. { Returns the NEW datenumber for a given datenumber that is increased/decreased
  68.   by user selected values.  Example: -2 for years, decreases the years by two }
  69.  
  70. implementation
  71.  
  72. const
  73.   months:array[1..12] of word=(31,59,90,120,151,181,212,243,273,304,334,365);
  74.  
  75. type
  76.   intstr=array[0..3] of byte;
  77.  
  78. function isleap(year:word):boolean;
  79. { This is used internally only by the other procedures/functions }
  80. begin
  81.   isleap:=false;
  82.   if year mod 100=0 then isleap:=year mod 400=0 else
  83.     isleap:=year mod 4=0;
  84. end;
  85.  
  86. function daynumber(datenum:longint):word;
  87. begin
  88.   daynumber:=(datenum+5) mod 7;
  89. end;
  90.  
  91. function daystring(daynum:word):str9;
  92. begin
  93.   daystring:=daystr[daynum];
  94. end;
  95.  
  96. function monthstring(monthnum:word):str9;
  97. begin
  98.   monthstring:=monthstr[monthnum];
  99. end;
  100.  
  101. function validdate(month,day,year:word):boolean;
  102. begin
  103.   validdate:=false;
  104.   if (month>=1) and (month<=12) then begin
  105.     if (year>=minyear) and (year<=maxyear) then begin
  106.       if day>=1 then begin
  107.         case month of
  108.           1,3,5,7,8,10,12:validdate:=day<=31;
  109.                  4,6,9,11:validdate:=day<=30;
  110.                         2:if isleap(year) then validdate:=day<=29 else
  111.                             validdate:=day<=28;
  112.         end;
  113.       end;
  114.     end;
  115.   end;
  116. end;
  117.  
  118. function datenumber(month,day,year:word):longint;
  119. var i:word; temp:longint;
  120. begin
  121.   temp:=0;
  122.   if year>minyear then begin
  123.     for i:=minyear to year-1 do
  124.       temp:=temp+365+(1*ord(isleap(i)));
  125.   end;
  126.   if month>2 then begin
  127.     temp:=temp+months[month-1]+day+1*ord(isleap(year));
  128.   end else temp:=temp+day+(31*ord(month>1));
  129.   datenumber:=temp;
  130. end;
  131.  
  132. procedure numberdate(datenum:longint; var month,day,year:word);
  133. var i:word; temp:longint; finished,leap:boolean;
  134. begin
  135.     temp:=0; i:=minyear-1; finished:=false;
  136.     repeat
  137.       inc(i);
  138.       temp:=temp+365+1*ord(isleap(i));
  139.       if temp>=datenum then begin
  140.         temp:=temp-(365+1*ord(isleap(i)));
  141.         temp:=datenum-temp;
  142.         finished:=true;
  143.       end;
  144.     until finished or (i>=maxyear);
  145.     year:=i;
  146.   leap:=isleap(year);
  147.   i:=1; finished:=false;
  148.   while not finished and (i<=12) do begin
  149.     if months[i]+1*((ord(leap)) and (ord(i>1))) >=temp then begin
  150.       month:=i;
  151.       if month>2 then begin
  152.         day:=temp-(months[i-1]+1*((ord(leap)) and (ord(i-1>1))));
  153.       end else day:=temp-(31*ord(month>1));
  154.       finished:=true;
  155.     end;
  156.     inc(i);
  157.   end;
  158. end;
  159.  
  160. function today:longint;
  161. var year,month,day,daynum:word;
  162. begin
  163.   getdate(year,month,day,daynum);
  164.   today:=datenumber(month,day,year);
  165. end;
  166.  
  167. function agetoday(datenum:longint):word;
  168. var tmonth,tday,tyear,bmonth,bday,byear,age:word;
  169. begin
  170.   numberdate(datenum,bmonth,bday,byear);
  171.   numberdate(today,tmonth,tday,tyear);
  172.   age:=tyear-byear;
  173.   if (tmonth<bmonth) or ((tmonth=bmonth) and (tday<bday)) then dec(age);
  174.   agetoday:=age;
  175. end;
  176.  
  177. function numstring(datenum:longint):str3;
  178. var datestr:intstr absolute datenum; i:byte; temp:str3;
  179. begin
  180.   for i:=0 to 2 do
  181.     temp[3-i]:=chr(datestr[i]);
  182.   temp[0]:=#3;
  183.   numstring:=temp;
  184. end;
  185.  
  186. function stringnum(numstr:string):longint;
  187. var temp:intstr; datenum:longint absolute temp; i:byte;
  188. begin
  189.   for i:=0 to 2 do
  190.     temp[2-i]:=ord(numstr[i+1]);
  191.     temp[3]:=0;
  192.   stringnum:=datenum;
  193. end;
  194.  
  195. function bumpdate(datenum:longint; months,days,years:integer):longint;
  196. { I fixed some problems in the original dates unit. If you subtract or add
  197.   one year from 2/29/1600 (a leap year) for example, you will get 3/1/1599
  198.   or 3/1/1601. This is a correct date considering there is no Feb. 29 in
  199.   either of the two years.  Also any date that exceeds 2300 or is smaller
  200.   than 1583 will not change the year, just the month/day numbers. }
  201. var month,day,year:word; temp:longint; tmonth:integer;
  202. begin
  203.   numberdate(datenum,month,day,year);
  204.   tmonth:=month;
  205.   tmonth:=tmonth+months-1;
  206.   year:=year+years+(tmonth div 12)-ord(tmonth<0);
  207.   tmonth:=(tmonth+12000) mod 12+1;
  208.   month:=tmonth;
  209.   temp:=datenumber(month,day,year)+days;
  210.   numberdate(temp,month,day,year);
  211.   bumpdate:=datenumber(month,day,year);
  212. end;
  213.  
  214. end.
  215.